home *** CD-ROM | disk | FTP | other *** search
/ InterCD 2001 May / may_2001.iso / intercd / root / ^Php / Perl_Feature_Tutorial / NETMAG / FEEDBACK.PL < prev    next >
Encoding:
Perl Script  |  2001-01-21  |  7.4 KB  |  216 lines
  1. #!/usr/bin/perl -w
  2.  
  3. #################################################
  4. # feedback.pl
  5. # Customer feedback to email form
  6. # Matt Kynaston (kynaston@yahoo.com), 2001
  7. # sample feedback form for .net magazine's CGI series, issue 82
  8. # www.netmag.co.uk
  9. # use, abuse, modify or mock,
  10. # just don't hold me responsible
  11. #
  12. # I've made a number of additions to the example code printed
  13. # in the magazine. I've done my best to comment them so you
  14. # can see the techniques I've employed.
  15.  
  16. #################################################
  17. # use standard CGI module. 
  18.  
  19. use CGI qw(:standard);
  20.  
  21.  
  22. #################################################
  23. # configuration section - modify to suit your environment
  24. # notice I've added a 'products' array
  25.  
  26. $mailprog='sendmail -t'; # full path to mail program
  27. $recipient='kynaston@uklinux.net'; # return email address
  28. $returl='../index.html'; # page to forward to once done
  29. @products = ["Baby Bags","Goat Skis","Fish Lids"];
  30.  
  31. # path to RobMail's adduser script, used to subscribe users to 
  32. # the email newsletter.
  33. $adduser = '/cgi-bin/adduser.cgi';
  34.  
  35. # set nosend to 1 to avoid dialing up and sending mail - good
  36. # for debugging locally
  37. $nosend = 0; 
  38.  
  39.  
  40. #################################################
  41. # create new CGI object called $q
  42.  
  43. $q = new CGI;
  44.  
  45.  
  46. #################################################
  47. # new: check form parameters and forward to correct section
  48.  
  49. &check_form;
  50.  
  51.  
  52. #################################################
  53. # print_form
  54. # prints out form asking for name, email, product from
  55. # drop-down list, whether they want to subscribe to newsletter
  56. # submits it back to this script the return URL
  57. #
  58. # I've changed a couple of things from the version in the mag:
  59. #     print_form can now be called from check_form, printing a
  60. #     message at the top of the page. It will also automatically
  61. #    repopulate its fields with the values typed previously
  62.  
  63. sub print_form {    
  64.     print $q->header,
  65.         $q->start_html(-bgcolor=>"#FF8000",
  66.             -title=>"Customer Feedback Form"),
  67.         $q->h1("Customer Feedback");
  68.     
  69.     # check to see if print_form called with an argument (from check_form)
  70.     # if so, print out the message. @_ is an array containing all the arguments
  71.     # passed to a function, $_[0] the first argument in this array
  72.     if (@_) {
  73.         print $q->hr,
  74.             $q->p($_[0]),
  75.             $q->hr;
  76.     }
  77.     
  78.     print $q->start_form,
  79.         $q->p("Your name: ",
  80.             $q->textfield(-name=>"name",
  81.                 -default=>$q->param("name")),
  82.              "*"),
  83.         $q->p("Your email: ",
  84.             $q->textfield(-name=>"from",
  85.                 -default=>$q->param("from")),
  86.             "*"),
  87.         $q->p("Which product are you using? ", 
  88.             $q->popup_menu(-name=>"product",
  89.                 -values=>@products, 
  90.                 -default=>$q->param("product"))),
  91.         $q->textarea(-name=>"comment",
  92.             -default=>$q->param("comment") ? $q->param("comment") : "type your comments here",
  93.             -rows=>10,
  94.             -columns=>50),
  95.         $q->p($q->checkbox(-name=>"newsletter",
  96.                 -checked=>$q->param("checked") ? "on" : undef,
  97.                 -label=>"Subscribe to newsletter?")),
  98.         $q->p($q->font({-size=>"-1"}),"The * denotes required fields"),
  99.         $q->p($q->submit("Send"), $q->defaults("Clear")),
  100.         $q->end_form,
  101.         $q->end_html;
  102. }
  103.  
  104. #################################################
  105. # send_mail
  106. # sends formatted mail to the mail program
  107. # subscribes customer to RobMail newsletter (if appropriate)
  108. # thanks customer and automatically forwards to return URL or
  109. # sends on to newsletter submission (if requested)
  110.  
  111. sub send_mail {
  112.     # notice how I've added redirection to the header and
  113.     # background colour to the body tag
  114.     if ($q->param("newsletter") ne "on") {
  115.         print $q->header(-Refresh=>"10; URL=$returl");
  116.     } else { print $q->header }
  117.     
  118.     print start_html(-bgcolor=>"#8080FF",-title=>"Thank you!");
  119.         
  120.     if (!$nosend) {
  121.         open (MAIL, "|$mailprog") || die_with_error("Can't open $mailprog! Error no: $!");
  122.         print MAIL "To: $recipient\n",
  123.                 "From: ", $q->param("from"), "\n",
  124.                 "Subject: Customer Feedback\n",
  125.                 "Re - ", $q->param("product"), "\n\n",
  126.                 $q->param("comment"), "\n";
  127.         close (MAIL) || die_with_error("Can't close $mailprog! Error no: $!");
  128.     }    
  129.         
  130.     print $q->h1("Thanks for your feedback, ", $q->param("name"));
  131.     
  132.     if ($q->param("newsletter") ne "on") {
  133.         print $q->p("This page should automatically return you the main menu in 10 seconds."),
  134.             $q->p("If it doesn't, just click the following link: ");
  135.  
  136.     } else {
  137.         print $q->start_form(-action=>$adduser),
  138.             $q->hidden(-name=>"name",-value=>$q->param("name")),
  139.             $q->hidden(-name=>"email",-value=>$q->param("from")),
  140.             $q->hidden(-name=>"what",-value=>"add"),
  141.             $q->hidden(-name=>"list",-value=>"default"),
  142.             $q->p("Click here to continue to newsletter subscription",
  143.                 $q->submit("Subscribe"),
  144.                 "or follow the link below:"),
  145.             $q->end_form;
  146.     }
  147.     print $q->p($q->a({-href=>$returl},"Return to main menu")),
  148.         $q->end_html;        
  149. }
  150.  
  151. #################################################
  152. # check_form
  153. # makes sure that all details filled in correctly, otherwise reprints
  154. # form. If OK, validates data then calls send_mail
  155. #
  156. # Uses a regular expression to check the email, which I haven't 
  157. # had the space to discuss in the mag. The first part of the
  158. # 'elsif' statement basically states:
  159. #      if the email parameter starts with one or more
  160. #    hyphen, alpha-numerics or dots, followed by an '@' sign,
  161. #    followed by one or more hyphen/alphanumerics/dots,
  162. #    followed by a full stop plus one or more alphanumerics
  163. #    characters, evaluate to true
  164. # OK, it's not exactly readable, but try creating such precise
  165. # string conditions any other way! See the perlre section of the
  166. # core Perl documentation and for more details
  167.  
  168. sub check_form {
  169.     if (!$q->param()) {
  170.         &print_form;
  171.     } elsif ($q->param("from") =~ /^[-\w\.]+\@[-\w\.]+\.\w+/ && $q->param("name") =~ /\w/) {
  172.         foreach $pname ($q->param) {        
  173.             $q->param($pname, strip_unsafe($q->param($pname)));                
  174.         }
  175.         &send_mail;
  176.     } else { 
  177.         print_form("Please make sure you fill in all the required fields.");    
  178.     }    
  179. }
  180.  
  181. #################################################
  182. # strip_unsafe
  183. # performs some basic security by removing any characters that
  184. # may screw with the mail program. Sendmail is fairly robust, but
  185. # it's a good idea to perform similar validation on any data you
  186. # send to a program (or database) on your host's computer to 
  187. # prevent a malicious user compromising security.
  188. # Notes: we do this by removing characters we haven't approved 
  189. # (the ^ means "not in this list") rather than looking for possibly 
  190. # troublesome characters, since there will always be some we 
  191. # haven't thought of! Never approve the shell escape "\" unless
  192. # you're sure the program you're sending it to can handle it.
  193. #
  194. # This is pretty rudimentary, but it might stop casual meddlers.
  195. # For more information on securing your Perl scripts, take a 
  196. # look at perlsec in the core Perl documentation and the notes
  197. # on Denial of Service in the CGI library documentation. 
  198.  
  199. sub strip_unsafe {
  200.     $_ = $_[0];
  201.     s/[^\s\w\+\-\@\,\.\!\?\/\(\)\[\{\}\"\'\รบ\$\%\&\*\~\#\<\>]//mg;
  202.     return $_;
  203. }
  204.  
  205. #################################################
  206. # die_with_error
  207. # prints error message to browser then dies
  208. # assumes that the content header has already been sent
  209.  
  210. sub die_with_error {
  211.     print $q->h1("An error occured while processing this script:"),
  212.         $q->p($_[0]),
  213.         $q->p("Try sending your comment again. If the problem persists, please contact the webmaster"),
  214.         $q->end_html;        
  215.     die;
  216. }